package provide tomsColorPaletteLib 1.0;

#TTD
#unset spots in the palette:
#  label with a bitmap?
#  keep flat?
#  reverse relief?
#selections
#  highlight border?
#  reverse relief?
#  wider border?
#more buttons?  apply button?  add button?  delete button?

#if applycommand has been set, then clicking on current color or on any
#color in palette does that command
#dragging works everywhere, unless dragging was specifically disabled

#USER COMMANDS
#  mkPalette newtoplevel palette_rows palette_columns
#      create a palette widget
#  addPaletteColors list of colors ...
#      adds the colors to the palette widget
#  removePaletteColors list of colors
#      removes colors from the palette (if found)
#  getPaletteCurrent
#      returns the currently selected color in the palette widget
#  clearPalette
#      removes all memorized colors from the palette widget
#  showPalette
#      deiconifies and raises the palette window
#  hidePalette
#      withdraws the palette window
#  
#  mkPalettePot withinwindow width height startcolor drop_handler_command
#      creates a paint pot in the specified widget (usually a frame)
#      withinwindow, which must be created before calling this proc.
#      withinwindow will be used to refer to this pot in the future
#  setPalettePot potwindow color
#      changes the color available in a paint pot
#  acceptPaletteDrop window drop_handler_command
#      sets up any widget to handle a paint drop
#
#  future possibilities:
#  bring up a quick menu of colors???
#  tie a command interactively to the palette (so that the sliders on the
#    palette can be interactively linked to things)
#    palette_applycmd command
#      command gets color tacked on and then gets executed 
#    palette_interactcmd command
#      command is called every time a slider is used
#  get the currently selected color (if selections are being used)
#    palette_current
#      returns the currently selected color
#  palette_enable dragdrop | selections | apply | interact
#  palette_disable dragdrop | selections | apply | interact

namespace eval ::tomsColorPaletteLib:: {
  namespace export mkPalette mkPalettePot acceptPaletteDrop \
	    setPalettePot showPalette hidePalette addPaletteColors \
	    removePaletteColors clearPalette getPaletteCurrent
  #incorporating USER combats permissions problems on multi-user systems
  variable cursor_file /tmp/tomsColPalCurs.$env(USER)
}

proc ::tomsColorPaletteLib::mkPalette {w width height} {
  variable palette
  variable palette_info
  variable cursor_file
  set palette_info(height) $height
  set palette_info(width) $width
  set palette_info(window) $w
  set palette_info(dragging) 0
  toplevel $w

  set palette_info(current) ""
  set palette_info(bg) [$w cget -bg]

  frame $w.f -borderwidth 3 -relief sunken -highlightthickness 2 -highlightbackground $palette_info(bg)
  label $w.f.color -relief flat -borderwidth 2 -background #000000 -width 12
  scale $w.red -from 0 -to 255 -troughcolor #b00000 -orient horizontal \
      -command "[namespace code palette_setcolor] $w" -activebackground #d00000 \
      -width 8 -showvalue 0 -highlightthickness 0
  scale $w.green -from 0 -to 255 -troughcolor #00b000 -orient horizontal \
      -command "[namespace code palette_setcolor] $w" -activebackground #00d000 \
      -width 8 -showvalue 0 -highlightthickness 0
  scale $w.blue -from 0 -to 255 -troughcolor #0000b0 -orient horizontal \
      -command "[namespace code palette_setcolor] $w" -activebackground #0000d0 \
      -width 8 -showvalue 0 -highlightthickness 0
  label $w.hex

  bind $w.f.color <Button-1> [namespace code {palette_press %W %x %y $palette_info(setbox_color)}]
  bind $w.f.color <B1-Motion> [namespace code "palette_dragging %x %y"]
  bind $w.f.color <ButtonRelease-1> [namespace code "palette_release %t %x %y"]
  bind $w.f.color <Enter> [namespace code "palette_enter %W %t"]

  frame $w.p
  for {set j 0} {$j<$height} {incr j} {
    for {set i 0} {$i<$width} {incr i} {
      frame $w.p.x${i}y$j -width 16 -height 16 -relief raised -bd 1 \
	      -highlightthickness 2 -highlightbackground $palette_info(bg)
      grid $w.p.x${i}y$j -row $j -column $i -padx 1 -pady 1
      bind $w.p.x${i}y$j <Button-1> [namespace code "palette_press %W %x %y \$palette($i,$j)"]
      bind $w.p.x${i}y$j <B1-Motion> [namespace code "palette_dragging %x %y"]
      bind $w.p.x${i}y$j <ButtonRelease-1> [namespace code "palette_release %t %x %y"]
      bind $w.p.x${i}y$j <Enter> [namespace code "palette_enter %W %t"]
      bind $w.p.x${i}y$j <Button-3> [namespace code "palette_remove_from %W"]
      set palette($i,$j) ""
    }
  }

  pack $w.p -side left

  pack $w.f.color -side top
  pack $w.f -side top -padx 10 -pady 10
  pack $w.red -side top
  pack $w.green -side top
  pack $w.blue -side top
  pack $w.hex -pady 10

  wm protocol $w WM_DELETE_WINDOW "wm withdraw $w"

  if ![file exists "$cursor_file.xbm"] {
    if [catch "open $cursor_file.xbm w" fh] {
      return 0
    }
    puts $fh "#define glassbig_width 16
#define glassbig_height 16
#define glassbig_x_hot 0
#define glassbig_y_hot 9
static char glassbig_bits[] = {
   0x00, 0x00, 0x00, 0x01, 0x80, 0x02, 0x40, 0x04, 0x20, 0x08, 0x10, 0x08,
   0x08, 0x10, 0x04, 0x20, 0x02, 0x40, 0x04, 0x40, 0x08, 0x80, 0x30, 0x40,
   0x40, 0x20, 0x80, 0x10, 0x00, 0x0b, 0x00, 0x04};"
    close $fh
  }
  if ![file exists "$cursor_file.mask"] {
    if [catch "open $cursor_file.mask w" fh] {
      return 0
    }
    puts $fh "#define glassbigmask_width 16
#define glassbigmask_height 16
static char glassbigmask_bits[] = {
   0x00, 0x00, 0x00, 0x01, 0x80, 0x03, 0xc0, 0x06, 0x60, 0x0c, 0x30, 0x0c,
   0x18, 0x18, 0x0e, 0x30, 0xff, 0x7f, 0xff, 0x7f, 0xfb, 0xff, 0xf3, 0x7f,
   0xc1, 0x3f, 0x81, 0x1f, 0x00, 0x0f, 0x00, 0x04};"
    close $fh
  }
}

#
# this can be applied to any window in an application, to accept a drop
# from the palette.  It can be safely reapplied to alter the command,
# or in case the bindings were reset.
#
proc ::tomsColorPaletteLib::acceptPaletteDrop {window command} {
  variable palette_info
  set palette_info(dragcmd,$window) $command
  bind $window <Enter> +[namespace code {palette_enter %W %t}]
}

#
# this creates a paint pot that can be dropped on or dragged from
#
proc ::tomsColorPaletteLib::mkPalettePot {window width height startcolor apply_drop_command} {
  variable palette_info
  set w $palette_info(window)
  frame $window -bd 2 -relief sunken
  set startcolor [palette_name2hex $startcolor]
  frame $window.pot -width $width -height $height -bg $startcolor
  pack $window.pot
  set palette_info(dropcmd,$window.pot) $apply_drop_command
  set palette_info(ispot,$window.pot) 1
  bind $window.pot <Button-1> [namespace code {palette_press %W %x %y [%W cget -bg]}]
  bind $window.pot <B1-Motion> [namespace code "palette_dragging %x %y"]
  bind $window.pot <ButtonRelease-1> [namespace code "palette_release %t %x %y"]
  bind $window.pot <Enter> [namespace code "palette_enter %W %t"]
}

proc ::tomsColorPaletteLib::setPalettePot {pot color} {
  $pot.pot config -bg [palette_name2hex $color]
}

# make the palette visible, if it isn't
proc ::tomsColorPaletteLib::showPalette {} {
  variable palette_info
  set w $palette_info(window)
  wm deiconify $w
  raise $w
}

#hide the palette window
proc ::tomsColorPaletteLib::hidePalette {} {
  variable palette_info
  set w $palette_info(window)
  wm withdraw $w
}

proc ::tomsColorPaletteLib::addPaletteColors {args} {
  foreach c $args {
    palette_add $c
  }
}

proc ::tomsColorPaletteLib::removePaletteColors {args} {
  foreach c $args {
    palette_remove $c
  }
}

proc ::tomsColorPaletteLib::clearPalette {} {
  variable palette
  variable palette_info
  set w $palette_info(window)
  foreach key [array names palette] {
    scan $key %d,%d x y
    set palette($key) ""
    $w.p.x${x}y$y config -bd 1 -relief raised -bg $palette_info(bg)
  }
}

proc ::tomsColorPaletteLib::getPaletteCurrent {} {
  variable palette
  variable palette_info
  set w $palette_info(window)
  if [string length $palette_info(current)] {
    if {"$palette_info(current)"=="$w.f.color"} {
      return $palette_info(setbox_color)
    } elseif [string match $w.p.x*y* $palette_info(current)] {
      scan $palette_info(current) $w.p.x%dy%d x y
      return $palette($x,$y)
    } else {
      return [$w cget -bg]
    }
  } else {
    return $palette_info(setbox_color)
  }
}

#
# "private" procs
#

proc ::tomsColorPaletteLib::palette_setcolor {args} {
  variable palette_info
  set w $palette_info(window)
  set c [palette_rgb2hex [$w.red get] [$w.green get] [$w.blue get]]
  set palette_info(setbox_color) $c

  $w.f.color config -background $c
  $w.hex config -text $c
}

proc ::tomsColorPaletteLib::palette_add {color} {
  variable palette
  variable palette_info

  set w $palette_info(window)
  set color [palette_name2hex $color]
  set position [palette_find $color]
  if [string length $position] { return $position }
  for {set j 0} {$j<$palette_info(height)} {incr j} {
    for {set i 0} {$i<$palette_info(width)} {incr i} {
      if [string length $palette($i,$j)]==0 {
	set palette($i,$j) $color
	$w.p.x${i}y$j config -bg $color -relief flat -bd 0
	return "$i,$j"
      }
    }
  }
  return ""
}

proc ::tomsColorPaletteLib::palette_add_to {color window} {
  variable palette
  variable palette_info

  set position [palette_find $color]
  if [string length $position] { return $position }
  set w $palette_info(window)
  scan $window $w.p.x%dy%d x y
  #if this has a color in it, add the color elsewhere
  #(this will only happen on drops, not on clicks)
  if [string length $palette($x,$y)] {
    return [palette_add $color]
  }
  set palette($x,$y) $color
  $window config -bg $color -relief flat -bd 0
  return $x,$y
}

proc ::tomsColorPaletteLib::palette_remove {color} {
  variable palette
  variable palette_info

  set w $palette_info(window)
  set color [palette_name2hex $color]
  set position [palette_find $color]
  if [string length $position]==0 { return "" }
  set palette($position) ""
  scan $position %d,%d x y
  $w.p.x${x}y$y config -bd 1 -relief raised -bg $palette_info(bg)
  return $position
}

proc ::tomsColorPaletteLib::palette_remove_from {window} {
  variable palette
  variable palette_info

  set w $palette_info(window)
  scan $window $w.p.x%dy%d x y
  set palette($x,$y) ""
  $w.p.x${x}y$y config -bd 1 -relief raised -bg $palette_info(bg)
}

proc ::tomsColorPaletteLib::palette_swap {win1 win2} {
  variable palette
  variable palette_info
  set w $palette_info(window)
  scan $win1 $w.p.x%dy%d x1 y1
  scan $win2 $w.p.x%dy%d x2 y2
  set hold $palette($x1,$y1)
  set palette($x1,$y1) $palette($x2,$y2)
  set palette($x2,$y2) $hold
  if [string length $palette($x1,$y1)]==0 {
    $win1 config -bg $palette_info(bg) -relief raised -bd 1
  } else {
    $win1 config -bg $palette($x1,$y1) -relief flat -bd 0
  }
  if [string length $palette($x2,$y2)]==0 {
    $win2 config -bg $palette_info(bg) -relief raised -bd 1
  } else {
    $win2 config -bg $palette($x2,$y2) -relief flat -bd 0
  }
  if {"$palette_info(current)"=="$win1"} {
    palette_setsource $win2
  } elseif {"$palette_info(current)"=="$win2"} {
    palette_setsource $win1
  }
}

proc ::tomsColorPaletteLib::palette_press {w winx winy color} {
  variable palette
  variable palette_info
  set palette_info(dragx) $winx
  set palette_info(dragy) $winy
  set palette_info(dragfrom) $w
  set palette_info(dragcolor) $color
  set palette_info(dragging) 0
  set palette_info(dragFarEnough) 0
  set palette_info(droptime) 0
}

proc ::tomsColorPaletteLib::palette_dragging {winx winy} {
  variable palette
  variable palette_info
  variable cursor_file
  set c $palette_info(dragcolor)
  if [string length $c] {
    set palette_info(dragging) 1
    $palette_info(dragfrom) config -cursor "@$cursor_file.xbm $cursor_file.mask [palette_contrast $c] $c"
    if [expr abs($palette_info(dragx)-$winx)]>3||[expr abs($palette_info(dragy)-$winy)]>3 {
      set palette_info(dragFarEnough) 1
    }
  } else {
    set palette_info(dragging) 0
  }
}

#
# table of actions for drag/drops - same source and target is viewed as a click
#
#from: \To:|   widgetA       widgetB      paletteA     paletteB     setbox
#----------+-------------+-------------+-------------+-------------+------------
#widgetA   | apply curr  | apply widgA | add to pall | add to pall | set setbox
#widgetB   | apply widgB | apply curr  | add to pall | add to pall | set setbox
#paletteA | apply pallA | apply pallA | set current | reorder     | set setbox
#paletteB | apply pallB | apply pallB | reorder     | set current | set setbox
#setbox    | apply setbx | apply setbx | add to pall | add to pall | set current

proc ::tomsColorPaletteLib::palette_enter {dropwin tym} {
  variable palette_info
  set w $palette_info(window)
  if ($palette_info(dragging)) {
    set palette_info(dragging) 0
    #Did this enter come at the same time as the button release of the drop?
    #If it didn't, then the drop went unhandled, so lets just return.
    #This makes two big assumptions:
    #  1. the button release and enter events have the same timestamp
    #  2. the button release event arrives first
    if $tym!=$palette_info(droptime) {
      return
    }
    if {"$dropwin"=="$w.f.color"} {
      scan $palette_info(dragcolor) "#%2x%2x%2x" r g b
      $w.red set $r
      $w.green set $g
      $w.blue set $b
    } elseif [string match $w.p.x*y* $dropwin] {
      if [string match $w.p.x*y* $palette_info(dragfrom)] {
	palette_swap $dropwin $palette_info(dragfrom)
      } else {
	palette_setsource [palette_add_to $palette_info(dragcolor) $dropwin]
      }
    } else {
      if [string length $palette_info(dropcmd,$dropwin)]!=0 {
	eval $palette_info(dropcmd,$dropwin) $palette_info(dragcolor)
      }
      if [info exists palette_info(ispot,$dropwin)] {
	$dropwin config -bg $palette_info(dragcolor)
      }
    }
  }
}

proc ::tomsColorPaletteLib::palette_release {tym winx winy} {
  variable palette_info
  if ($palette_info(dragging)) {
    $palette_info(dragfrom) config -cursor ""
    set palette_info(droptime) $tym
    #drop will be handled by an enter, if it left the window
    if !$palette_info(dragFarEnough) {
      palette_click
    }
  } else {
    palette_click
  }
}

#
# UNUSED CRUFT
#
#proc ::tomsColorPaletteLib::palette_drop {w} {
#  variable palette
#  variable palette_info
#  set w $palette_info(window)
# 
#  if "$palette_info(dragfrom)"=="$w.f.color" {
#  } elseif [string match $w.p.x*y* $palette_info(dragfrom)] {
#  } else {
#  }
#}

proc ::tomsColorPaletteLib::palette_click {} {
  variable palette
  variable palette_info
  set w $palette_info(window)
  if {"$palette_info(dragfrom)"=="$w.f.color"} {
    #make the setbox the current color source
    palette_setsource $palette_info(dragfrom)
  } elseif [string match $w.p.x*y* $palette_info(dragfrom)] {
    #if this box has a color, make it the current color source
    #if it doesn't have a color, attempt to load the color in setbox
    #if this color is already in the palette, make it the current color
    #source.  if it was added, also make it the current color source
    scan $palette_info(dragfrom) $w.p.x%dy%d x y
    if [string length $palette($x,$y)] {
      palette_setsource $palette_info(dragfrom)
    } else {
      palette_setsource [palette_add_to $palette_info(setbox_color) $palette_info(dragfrom)]
    }
  } else {
    set color [getPaletteCurrent]
    if [string length $palette_info(dropcmd,$palette_info(dragfrom))]!=0 {
      eval $palette_info(dropcmd,$palette_info(dragfrom)) $color
    }
    if [info exists palette_info(ispot,$palette_info(dragfrom))] {
      $palette_info(dragfrom) config -bg $color
    }
  }
}

proc ::tomsColorPaletteLib::palette_setsource {w} {
  variable palette_info
  #allow x,y as an argument
  if [string match *,* $w] {
    scan $w %d,%d x y
    set w $palette_info(window).p.x${x}y$y
  }
  #don't set the highlight border using focus, because we don't want to
  #conflict with application's focus settings.  Just change the
  #highlightbackground color
  if [string length $palette_info(current)] {
    if {"$palette_info(current)"=="$palette_info(window).f.color"} {
      $palette_info(window).f config -highlightbackground $palette_info(bg)
    } else {
      $palette_info(current) config -highlightbackground $palette_info(bg)
    }
  }
  set palette_info(current) $w
  if {"$w"=="$palette_info(window).f.color"} {
    $palette_info(window).f config -highlightbackground black
  } else {
    $palette_info(current) config -highlightbackground black
  }
}

proc ::tomsColorPaletteLib::palette_find {color} {
  variable palette

  set color [palette_name2hex $color]
  foreach elem [array names palette] {
    if [string compare $palette($elem) $color]==0 {
      return $elem
    }
  }
  return ""
}

proc ::tomsColorPaletteLib::palette_name2hex {color} {
  set color [string tolower $color]
  if [regexp {^#[0-9a-f]..$} $color] {
    #f0f
    scan $color #%1x%1x%1x r g b
    set color [palette_rgb2hex [expr $r*16] [expr $g*16] [expr $b*16]]
  } elseif [regexp {^#[0-9a-f].....$} $color] {
    #ff00ff
    scan $color #%2x%2x%2x r g b
    set color [palette_rgb2hex $r $g $b]
  } elseif [regexp {^#[0-9a-f]........$} $color] {
    #fff000fff
    scan $color #%3x%3x%3x r g b
    set color [palette_rgb2hex [expr $r/256] [expr $g/256] [expr $b/256]]
  } elseif [regexp {^#[0-9a-f]...........$} $color] {
    #ffff0000ffff
    scan $color #%4x%4x%4x r g b
    set color [palette_rgb2hex [expr $r/256] [expr $g/256] [expr $b/256]]
  } else {
    #try to interpret it as a color name
    if [catch "winfo rgb . $color" rgb] {
      return ""
    }
    set color [palette_rgb2hex [expr [lindex $rgb 0]/256] \
	    [expr [lindex $rgb 1]/256] [expr [lindex $rgb 2]/256]]
  }
  return $color
}

proc ::tomsColorPaletteLib::palette_rgb2hex {r g b} {
  set r [format %2.2x $r]
  set g [format %2.2x $g]
  set b [format %2.2x $b]
  return "#$r$g$b"
}

#
# for a given color, figure out whether black or white would make a better
# contrast
# only accepts colors in the form #rrggbb
#
# XXX - needs to handle 12 digit colors (and other lengths too?)
proc ::tomsColorPaletteLib::palette_contrast {color} {
  scan $color "#%2x%2x%2x" r g b
  #these numbers are a standard greyscale conversion:
  #[expr 222*$r/255 + 707*$g/255 + 71*$b/255]
  #I didn't like the results
  #This is entirely empirical -- still not great
  if [expr 200*$r/255 + 250*$g/255 + 50*$b/255]>150 {
    return black
  } else {
    return white
  }
}
